home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 41.zip / BS1 part 41 / Compute`s Amiga resource 1.adf / Source / PowerPoker / powerpoker.mod
Text File  |  1989-02-07  |  10KB  |  416 lines
  1. MODULE PowerPoker;
  2.  
  3. FROM TermInOut IMPORT WriteLn, WriteString;
  4. FROM RandomNumbers IMPORT Random, Seed;
  5. FROM ReadPict IMPORT ReadPicture, ILBMFrame;
  6. FROM IFF IMPORT IFFP;
  7. FROM AmigaDOS IMPORT Open, Close, FileHandle, ModeOldFile;
  8. FROM AmigaDOSProcess IMPORT Delay;
  9. FROM SYSTEM IMPORT ADR, BYTE, WORD;
  10. FROM RemAlloc IMPORT ChipAlloc, RemFree;
  11. FROM SimpleScreens IMPORT CreateScreen, ScreenOptFlags;
  12. FROM SimpleWindows IMPORT CreateWindow;
  13. FROM Views IMPORT LoadRGB4;
  14. FROM Graphics IMPORT BitMap;
  15. FROM Drawing IMPORT SetAPen, RectFill;
  16. FROM SimpleIDCMP IMPORT MsgData, WindowProc, ProcIMsg;
  17. FROM Tasks IMPORT SignalSet, Wait;
  18. FROM Ports IMPORT GetMsg;
  19. FROM Rasters IMPORT RastPort;
  20. FROM Views IMPORT ViewPort, SetRGB4;
  21. FROM InputEvents IMPORT IEQualifier, IEQualifierSet;
  22. FROM Memory IMPORT MemReqSet, AvailMem;
  23. FROM Blit IMPORT BltBitMap, MinTermFlagsSet, WaitTOF, BltBitMapRastPort,
  24.  ClipBlit;
  25. FROM SimpleMenus IMPORT BeginMenuStrip, EndMenuStrip, FreeMenuStrip, AddMenu,
  26.  AddMenuItem, MenuItemOpt;
  27. FROM Intuition IMPORT CloseScreen, ScreenPtr, IDCMPFlagsSet, WindowFlagsSet,
  28.  WindowFlags, WindowPtr, CloseWindow, Window, IntuiMessagePtr, IDCMPFlags,
  29.  ClearMenuStrip, SetMenuStrip, MenuPtr, MenuItemFlagsSet, MenuItemFlags,
  30.  MenuItemMutualExcludeSet, HighComp, ITEMNUM, SelectDown, ScreenFlags,
  31.  ScreenFlagsSet, ScreenToFront, ScreenToBack, RethinkDisplay, CurrentTime;
  32.  
  33. CONST
  34.  CopyFlags = MinTermFlagsSet{6,7};
  35.  XORFlags = MinTermFlagsSet{5,6};
  36.  WIDCMP = IDCMPFlagsSet{MenuPick,MouseButtons,MenuVerify};
  37.  WFlags = WindowFlagsSet{Activate,Borderless};
  38.  MFlags = MenuItemFlagsSet{ItemText,ItemEnabled,CommSeq}+HighComp;
  39.  MIMEFlags = MenuItemMutualExcludeSet{};
  40.  Shifts = IEQualifierSet{IEQualifierLShift,IEQualifierRShift,
  41.           IEQualifierCapsLock};
  42.  IEQNULL = IEQualifierSet{};
  43.  All = BYTE(0FFH);
  44.  ScrFlags = ScreenFlagsSet{ScreenBehind};
  45.  
  46. VAR Scr: ScreenPtr;
  47.  sig: SignalSet;
  48.  msg: IntuiMessagePtr;
  49.  wp: WindowProc;
  50.  ms: MenuPtr;
  51.  rp: RastPort;
  52.  vp: ViewPort;
  53.  i, j, k, Suit, Rank, Card, Best, Score, HighScore : CARDINAL;
  54.  pic, pic2: FileHandle;
  55.  res: IFFP;
  56.  frame: ILBMFrame;
  57.  bm, bm2: BitMap;
  58.  win :  WindowPtr;
  59.  name: ARRAY [1..18] OF CHAR;
  60.  Table: ARRAY [1..5],[1..5] OF BOOLEAN;
  61.  TRank, TSuit: ARRAY [1..5],[1..5] OF CARDINAL;
  62.  result, Restart, Done, AllSameSuit: BOOLEAN;
  63.  DeckSuit, DeckRank: ARRAY [1..52] OF CARDINAL;
  64.  InRow, InColumn, Hand : ARRAY [1..5] OF CARDINAL;
  65.  Hold : ARRAY [1..14] OF CARDINAL;
  66.  Power : ARRAY [1..4] OF CARDINAL;
  67.  ScoreTable : ARRAY [0..9] OF CARDINAL;
  68.  
  69. PROCEDURE Swap(VAR x,y:CARDINAL);
  70.  
  71. VAR t: CARDINAL;
  72.  
  73. BEGIN
  74.  t := x;
  75.  x := y;
  76.  y := t;
  77. END Swap;
  78.  
  79. PROCEDURE WriteScore(Score,LeftPlace: CARDINAL);
  80.  
  81. VAR Digit: CARDINAL;
  82.  
  83. BEGIN
  84.  j := Score;
  85.  FOR i := 1 TO 4 DO
  86.   Digit := j DIV Power[i];
  87.   BltBitMapRastPort(bm2,10*Digit+21,1,rp,LeftPlace+i*9,32,8,7,CopyFlags);
  88.   j := j-Digit*Power[i];
  89.  END;
  90. END WriteScore;
  91.  
  92. PROCEDURE Evaluate(AllSameSuit:BOOLEAN);
  93.  
  94. VAR
  95.  i, j, temp, One, Two, Three, Four: CARDINAL;
  96.  Straight, Royal: BOOLEAN;
  97.  
  98. BEGIN
  99.  One := 0; Two := 0; Three := 0; Four := 0;
  100.  FOR i := 2 TO 14 DO
  101.   Hold[i] := 0;
  102.  END;
  103.  FOR i := 1 TO 5 DO
  104.   INC(Hold[Hand[i]]);
  105.  END;
  106.  Hold[1] := Hold[14];
  107.  FOR i := 2 TO 14 DO
  108.   CASE Hold[i] OF
  109.    1: INC(One);|
  110.    2: INC(Two);|
  111.    3: INC(Three);|
  112.    4: INC(Four);
  113.   END;
  114.  END;
  115.  Best := 0;
  116.  IF Four=1 THEN
  117.   Best := 7; (*Four Of A Kind*)
  118.  END;
  119.  IF (Three=1) THEN
  120.   IF (Two=1) THEN
  121.    Best := 5; (*Full House*)
  122.   ELSE
  123.    Best := 4; (*Three Of A Kind*)
  124.   END;
  125.  END;
  126.  IF Best=0 THEN
  127.   IF Two=2 THEN
  128.    Best := 2; (*Two Pair*)
  129.   END;
  130.   IF Two=1 THEN
  131.    Best := 1; (*One Pair*)
  132.   END;
  133.  END;
  134.  Straight := FALSE;
  135.  Royal := FALSE;
  136.  IF One=5 THEN
  137.   FOR i := 1 TO 4 DO
  138.    FOR j := i+1 TO 5 DO
  139.     IF Hand[i]>Hand[j] THEN
  140.      Swap(Hand[i],Hand[j]);
  141.     END;
  142.    END;
  143.   END;
  144.   Straight := ((Hand[5]-Hand[1])=4) OR
  145.               ((Hand[5]=14) AND (Hand[1]=2) AND (Hand[4]=5));
  146.   Royal := (Hand[5]=14) AND (Hand[1]=10);
  147.  END;
  148.  IF (Straight OR Royal) AND (Best<6) THEN
  149.   Best := 6; (*Straight*)
  150.  END;
  151.  IF AllSameSuit THEN
  152.   IF (Best<3) THEN
  153.    Best := 3;
  154.   END;
  155.   IF Straight THEN
  156.    Best := 8; (*Straight Flush*)
  157.   END;
  158.   IF Royal THEN
  159.    Best := 9; (*Royal Flush*)
  160.   END;
  161.  END;
  162.  Score := Score+ScoreTable[Best];
  163.  WriteScore(Score,435);
  164.  IF Score>1000 THEN
  165.   SetRGB4(vp,3,15,10,5);
  166.   RethinkDisplay;
  167.  END;
  168.  IF Score>HighScore THEN
  169.   HighScore := Score;
  170.   WriteScore(HighScore,554);
  171.  END;
  172. END Evaluate;
  173.  
  174. PROCEDURE MenuHandler(VAR w:Window; VAR msg: MsgData; menu: CARDINAL);
  175.  
  176. VAR men,ite,sub: CARDINAL;
  177.  
  178. BEGIN
  179.  ite := ITEMNUM(menu);
  180.  CASE ite OF
  181.   0: Restart := TRUE;|
  182.   1: ScreenToBack(Scr^);|
  183.   2: Done := TRUE;
  184.  END;
  185. END MenuHandler;
  186.  
  187. PROCEDURE SumRow(Row: CARDINAL);
  188.  
  189. VAR temp: CARDINAL;
  190.  
  191. BEGIN
  192.  temp := Row*38-32;
  193.  FOR i := 1 TO 6 DO
  194.   res:=BltBitMap(bm,8,temp,Scr^.BitMap,8,temp,336,33,XORFlags,BYTE(1),NIL);
  195.   Delay(12);
  196.  END;
  197.  AllSameSuit := TRUE;
  198.  FOR i := 1 TO 5 DO
  199.   Hand[i] := TRank[i,Row];
  200.   IF TSuit[i,Row]<>TSuit[1,Row] THEN
  201.    AllSameSuit := FALSE;
  202.   END;
  203.  END;
  204.  Evaluate(AllSameSuit);
  205. END SumRow;
  206.  
  207. PROCEDURE SumColumn(Column: CARDINAL);
  208.  
  209. VAR temp: CARDINAL;
  210.  
  211. BEGIN
  212.  temp := Column*66-52;
  213.  FOR i := 1 TO 6 DO
  214.   res:=BltBitMap(bm,temp,6,Scr^.BitMap,temp,6,60,186,XORFlags,BYTE(1),NIL);
  215.   Delay(12);
  216.  END;
  217.  AllSameSuit := TRUE;
  218.  FOR i := 1 TO 5 DO
  219.   Hand[i] := TRank[Column,i];
  220.   IF TSuit[Column,i]<>TSuit[Column,1] THEN
  221.    AllSameSuit := FALSE;
  222.   END;
  223.  END;
  224.  Evaluate(AllSameSuit);
  225. END SumColumn;
  226.  
  227. PROCEDURE MoveCard(x,y:CARDINAL):BOOLEAN;
  228.  
  229. VAR temp: BOOLEAN;
  230.  
  231. BEGIN
  232.  temp := FALSE;
  233.  IF (x>0) AND (x<6) AND (y>0) AND (y<6) THEN
  234.   temp := ~Table[x,y];
  235.   IF temp THEN
  236.    ClipBlit(rp,468,159,rp,x*66-52,y*38-32,58,32,CopyFlags);
  237.    Table[x,y] := TRUE;
  238.    TRank[x,y] := Rank;
  239.    TSuit[x,y] := Suit;
  240.    SetAPen(Scr^.RastPort,8);
  241.    RectFill(Scr^.RastPort,469,160,469+56,160+30);
  242.    INC(InRow[y]);
  243.    IF InRow[y]=5 THEN
  244.     SumRow(y);
  245.    END;
  246.    INC(InColumn[x]);
  247.    IF InColumn[x]=5 THEN
  248.     SumColumn(x);
  249.    END;
  250.   END;
  251.  END;
  252.  RETURN temp;
  253. END MoveCard; 
  254.  
  255. PROCEDURE DrawCard(Suit, Rank: CARDINAL);
  256.  
  257. VAR temp1, temp2 : CARDINAL;
  258.  
  259. BEGIN
  260.  SetAPen(Scr^.RastPort,1);
  261.  RectFill(Scr^.RastPort,469,160,469+56,160+30);
  262.  IF Suit>2 THEN
  263.   temp1 := 49;
  264.  ELSE
  265.   temp1 := 89;
  266.  END;
  267.  temp2 := Rank*12+1;
  268.  BltBitMapRastPort(bm2,113,Suit*24-12,rp,486,169,24,13,CopyFlags);
  269.  BltBitMapRastPort(bm2,temp1,temp2,rp,469,160,18,11,CopyFlags);
  270.  BltBitMapRastPort(bm2,temp1,temp2,rp,506,180,18,11,CopyFlags);
  271. END DrawCard;
  272.  
  273. PROCEDURE Shuffle;
  274.  
  275. VAR i,j: CARDINAL;
  276.  
  277. BEGIN
  278.  FOR i := 1 TO 52 DO
  279.   DeckSuit[i] := i MOD 4+1;
  280.   DeckRank[i] := i MOD 13+2;
  281.  END;
  282.  FOR i := 1 TO 52 DO
  283.   j := CARDINAL(Random(52))+1;
  284.   Swap(DeckSuit[i],DeckSuit[j]);
  285.   Swap(DeckRank[i],DeckRank[j]);
  286.  END;
  287.  Score := 0;
  288.  Card := 1;
  289.  BltBitMapRastPort(bm2,152,14,rp,388,30,216,11,CopyFlags);
  290.  WriteScore(HighScore,554);
  291.  Suit := DeckSuit[Card];
  292.  Rank := DeckRank[Card];
  293.  DrawCard(Suit,Rank);
  294.  Card := 2;
  295. END Shuffle;
  296.  
  297. PROCEDURE MouseHandler(VAR w:Window; VAR msg: MsgData; buttons: CARDINAL);
  298.  
  299. BEGIN
  300.  IF buttons=SelectDown THEN
  301.   WITH msg DO
  302.    result := MoveCard((MouseX+52) DIV 66,(MouseY+32) DIV 38);
  303.    IF result THEN
  304.     Suit := DeckSuit[Card];
  305.     Rank := DeckRank[Card];
  306.     DrawCard(Suit,Rank);
  307.     INC(Card);
  308.    END;
  309.   END;
  310.  END;
  311. END MouseHandler;
  312.  
  313. PROCEDURE MenuVerifyHandler(VAR w:Window; VAR mag:MsgData);
  314.  
  315. BEGIN
  316. END MenuVerifyHandler;
  317.  
  318. BEGIN
  319.  HighScore := 0;
  320.  Power[1] := 1000; Power[2] := 100; Power[3] := 10; Power[4] := 1;
  321.  ScoreTable[0] := 0; ScoreTable[1] := 10; ScoreTable[2] := 30;
  322.  ScoreTable[3] := 50; ScoreTable[4] := 60; ScoreTable[5] := 100;
  323.  ScoreTable[6] := 120; ScoreTable[7] := 160; ScoreTable[8] := 300;
  324.  ScoreTable[9] := 400;
  325.  WriteLn;
  326.  WriteString("        Power Poker");
  327.  WriteLn;
  328.  WriteString("©1989 COMPUTE! Publications");
  329.  WriteLn;
  330.  WriteString("    All Rights Reserved");
  331.  WriteLn;
  332.  WriteString("        Please Wait");
  333.  WriteLn;
  334.  IF AvailMem(MemReqSet{1})<250000D THEN
  335.   WriteString("==INSUFFICIENT MEMORY==");
  336.   WriteLn;
  337.   Delay(200);
  338.   RETURN;
  339.  END;
  340.  name := "pp.bak";
  341.  pic := Open(ADR(name), ModeOldFile);
  342.  Close(pic);
  343.  name := "pp.objs";
  344.  pic2 := Open(ADR(name), ModeOldFile);
  345.  Close(pic2);
  346.  IF (pic=NIL) OR (pic2=NIL) THEN
  347.   WriteString("==CAN'T FIND GRAPHICS FILES==");
  348.   WriteLn;
  349.   Delay(200);
  350.   RETURN;
  351.  END;
  352.  WITH wp DO
  353.   procMouseButtons := MouseHandler;
  354.   procMenuPick := MenuHandler;
  355.   procMenuVerify := MenuVerifyHandler;
  356.  END;
  357.  BeginMenuStrip();
  358.   AddMenu(ADR(" Power Poker "));
  359.    AddMenuItem(ADR(" New Game "));
  360.    MenuItemOpt(MFlags,MIMEFlags,"N");
  361.    AddMenuItem(ADR(" Screen To Back "));
  362.    MenuItemOpt(MFlags,MIMEFlags,"W");
  363.    AddMenuItem(ADR(" Quit "));
  364.    MenuItemOpt(MFlags,MIMEFlags,"Q");
  365.  ms := EndMenuStrip();
  366.  ScreenOptFlags := WORD(ScrFlags);
  367.  Scr := CreateScreen(640,200,4,NIL);
  368.  win := CreateWindow(0,0,640,200,WIDCMP,WFlags,NIL,Scr,NIL);
  369.  rp := Scr^.RastPort;
  370.  vp := Scr^.ViewPort;
  371.  SetMenuStrip(win^,ms^);
  372.  name := "pp.bak";
  373.  pic := Open(ADR(name), ModeOldFile);
  374.  res := ReadPicture(pic,bm,frame,ChipAlloc);
  375.  Close(pic);
  376.  LoadRGB4(Scr^.ViewPort,ADR(frame.colorMap),16);
  377.  name := "pp.objs";
  378.  pic := Open(ADR(name), ModeOldFile);
  379.  res := ReadPicture(pic,bm2,frame,ChipAlloc);
  380.  Close(pic);
  381.  BltBitMapRastPort(bm,0,0,rp,0,0,640,200,CopyFlags);
  382.  ScreenToFront(Scr^);
  383.  CurrentTime(ADR(Seed),ADR(Seed));
  384.  Delay(100);
  385.  Shuffle;
  386.  REPEAT
  387.   FOR i := 1 TO 5 DO
  388.    FOR j := 1 TO 5 DO
  389.     Table[i,j] := FALSE;
  390.     SetAPen(Scr^.RastPort,8);
  391.     RectFill(Scr^.RastPort,i*66-51,j*38-31,i*66+5,j*38-1);
  392.    END;
  393.    InRow[i] := 0;
  394.    InColumn[i] := 0;
  395.   END;
  396.   Restart := FALSE;
  397.   WHILE (~Done) AND (~Restart) DO
  398.    sig := Wait(SignalSet{CARDINAL(win^.UserPort^.mpSigBit)});
  399.    LOOP
  400.     msg := GetMsg(win^.UserPort^);
  401.     IF (msg=NIL) THEN
  402.      EXIT;
  403.     END;
  404.     ProcIMsg(wp,msg);
  405.    END;
  406.   END;
  407.   Shuffle;
  408.  UNTIL (~Restart);
  409.  ClearMenuStrip(win^);
  410.  CloseWindow(win^);
  411.  CloseScreen(Scr^);
  412.  FreeMenuStrip(ms^);
  413.  RemFree(bm.Planes[0]);
  414.  RemFree(bm2.Planes[0]);
  415. END PowerPoker.
  416.